perm filename BITLAB.SOU[FOO,LMM] blob
sn#092632 filedate 1974-03-21 generic text, type T, neo UTF8
COMMON((PICTURE))
DEFINE(((MLG(LAMBDA(NODES GROUP LABELS)
(FOR NEW X IN
(MANYLABELGRAPHTOP (LST-BNR NODES)(LST-BNRG GROUP)LABELS)
DO (FOR NEW Y IN (CDR X) DO
(PRINC (CAR Y))
(PRINC(BNR-LST(CDR Y)))
(XTAB 2))
(COND((GET @ PICTURE @ APVAL)
(FOR NEW I :=(1 (FOR NEW II IN PICTURE MAX (CADR II))) DO
(TERPRI)
(FOR NEW P IN PICTURE WHEN (EQUAL I (CADR P))
AS NEW ELT IS (LST-BNR (CAR P))
AS NEW Y IS X DO
(COND((NOT(NUMBERP(CAR P)))(GO L2)))
(TTAB (CDDR P))
L1 (COND((NULL(SETQ Y(CDR Y)))(PRIN1 @ ?))
((DISJOINT ELT(CDAR Y))(GO L1))
(T(PRIN1 (CAAR Y))))
(GO L3)
L2 (PRIN1 (CAR P))
L3 ))))
(TERPRI)(PRIN1 @ GROUP=)
(TTAB 20)
(PRINT (BNR-LSTG (CAR X))))))))))))))
EJECT()
COMMENT(************************
ALL FUNCTIONS FROM HERE ON ARE INDEPENDENT OF THE
REPRESENTATION ;THEY ONLY REFER TO SETS BY THE
ABOVE FUNCTIONS * * * * * * * * * * * * * * * * * *)
COMMENT(ORBIT1
ARGS NODES A SET
GROUP A GROUP OF PERMUTATIONS ON NODES
VALUE THE SUBSET OF NODES WHICH IS THE ORBIT
OF (FIRST NODES) UNDER THE PERMUTATIONS OF
GROUP )
DEFINE(((ORBIT1(LAMBDA(NODES GROUP)
(PROG(CLASS)
(SETQ CLASS (FIRST NODES))
(FOR GROUP ON GROUP
FOR NEW PERM ON (CYCLESOF(CAR GROUP))
AS NEW CYCLE IS (SETOF (CAR PERM))
WHEN (NOT (DISJOINT CYCLE CLASS)) DO
(SETQ CLASS (UNION CYCLE CLASS)))
(RETURN (INTERSECT CLASS NODES))))))))
COMMENT(REDUCEGROUP
ARGS GROUP A GROUP OF PERMUTATIONS
NODES NODES WHICH HAVE NOW BEEN LABELED
VAL THE GROUP OR THE REMAINING STRUCTURE,ONCE
NODES HAVE BEEN LABELED )
DEFINE(((REDUCEGROUP(LAMBDA(GROUP NODES)
(FOR GROUP ON GROUP
WHEN (FOR NEW PERM ON (CYCLESOF(CAR GROUP))
AS NEW CYCLE IS (SETOF (CAR PERM))
AS NEW X IS (INTERSECT NODES CYCLE)
AND (OR(EMPTY X)(EQSET X CYCLE)))
LIST (CAR GROUP)))))))))))))))))))
COMMENT(COMB
ARGS NODES A SET
NUMBER NUMBER OF ELEMENTS WANTED IN EACH SUBSET
VAL LIST OF ALL SUBSETS OF NODES WITH NUMBER ELEMENTS )
DEFINE(((COMB(LAMBDA(NODES NUMBER)
(COND
((ZEROP NUMBER)(LIST (NULLSET)))
((EMPTY NODES) NIL)
((EQUAL NUMBER 1)(LISTELT NODES))
(T (FOR NEW FN IS (FIRST NODES)
AS NODES IS (REST NODES)
AS NEW NN :=((SIZE NODES) NUMBER -1)
FOR NEW X IN (COMB NODES (SUB1 NUMBER))
XLIST (UNION FN X))))))))
EJECT()
COMMENT(MANYLABELGRAPHTOP
THIS IS A SPECIAL TOP LEVEL FUNCTION WHICH CALLS
FIRST POLYA AND THEN MANYLABELGRAPH
IF THE RESULT OF THE POLYA FUNCTION SHOW THAT
THERE ARE TOO MANY STRUCTURES TO CALCULATE IN A
REASONABLE LENGTH OF TIME, MANYLABELGRAPH IS NOT
CALLED
)
SPECIAL((SZNODES))
DEFINE ((
(MANYLABELGRAPHTOP (LAMBDA (NODES GROUP LABELS)
(PROG (X SZNODES)(SETQ SZNODES(SIZE NODES))
(SETQ LABELS
(SORTBY
(LAMBDA (PAIR)
(DIFFERENCE
(TIMES 0.001 (CDR PAIR))
(ABS (DIFFERENCE
(TWICE (CDR PAIR))
SZNODES))))
LABELS))
(SETQ X (POLYA NODES GROUP LABELS))
(PRINT (CONS X @ (POSSIBLE SUBSTITUTION (S))))
(COND
((GREATERP X 1000)
(RETURN (PROG2
(PRINT @ (THIS IS TOO MANY TO COMPUTE))
NIL))))
(SETQ X (MANYLABELGRAPH NODES GROUP LABELS))
(PRINT (CONS (LENGTH X) @ (ACTUAL SUBSTITUTIONS MADE)))
(RETURN X))))
))
UNSPECIAL((SZNODES))
EJECT()
COMMENT(MANYLABELGRAPH
ARGS NODES SET TO BE LABELED
GROUP PERMUTATION GROUP ON NODES
LABELS A LIST OF DOTTED PAIRS OF LABEL,NUMBER
VAL LIST OF ALL NONEQUIVALENT LABELINGS OF NODES,
WHERE EACH LABELING IS A LIST OF THE FORM:
(GROUP (LABEL . NODES) (LABEL . NODES) (LABEL . NODES))
)
DEFINE(((MANYLABELGRAPH(LAMBDA(NODES GROUP LABELS)
(COND
((FOR LABELS ON LABELS AND (ZEROP(CDAR LABELS))) NIL)
((NULL (CDR LABELS))
(FOR NEW X IN(LABELGRAPH NODES GROUP (CDAR LABELS))
XLIST (LIST (CDR X)(CONS(CAAR LABELS)(CAR X)))))
(T (FOR NEW NODGRP IN (LABELGRAPH NODES GROUP (CDAR LABELS))
FOR NEW LABELING IN
(MANYLABELGRAPH
(DIFF NODES (CAR NODGRP))
(CDR NODGRP)
(CDR LABELS))
XLIST
(*CONS
(CAR LABELING)
(CONS (CAAR LABELS) (CAR NODGRP))
(CDR LABELING))))))))))))))
EJECT()
COMMENT(LABELGRAPH
ARGS NODES SET TO BE LABELED
GROUP PERMUTATION GROUP ON NODES
NUMBER NUMBER OF LABELS TO BE ATTACHED
VAL LIST OF ALL NONEQUIVALENT LABELINGS OF NODES WITH
)NUMBER> IDENTICAL LABELS, WHERE EACH LABELING
IS OF THE FORM:
(NODES . GROUP)
)
DEFINE(((LABELGRAPH(LAMBDA(NODES GROUP NUMBER)
(COND
((NULL GROUP)(FOR NEW X IN (COMB NODES NUMBER)XLIST(CONS X NIL)))
((GREATERP(TWICE NUMBER)(SIZE NODES))
(FOR NEW X IN(LABELGRAPH NODES GROUP(DIFFERENCE(SIZE NODES)NUMBER))
XLIST (CONS (DIFF NODES (CAR X))(CDR X))))
((ZEROP NUMBER)(LIST (CONS (NULLSET) GROUP)))
(T (PROG (FC RESULT )
(COND((EQSET NODES(SETQ FC(ORBIT1 NODES GROUP)))
(RETURN(LABELCLASS NODES GROUP NUMBER))))
(SETQ NODES (DIFF NODES FC))
(FOR NEW X :=((MAX 0(DIFFERENCE NUMBER(SIZE NODES)))
(MIN NUMBER (SIZE FC))
1)
AS NEW LBLGS IS (SORTBY CDR (LABELCLASS FC GROUP X))
AS NEW OLDGROUP IS @ UNDEFINED
AS NEW N-X IS (DIFFERENCE NUMBER X)
DO
(FOR LBLGS ON LBLGS
AS NEW LBLGS2 IS (IF(EQUAL(CDAR LBLGS)OLDGROUP)THEN LBLGS2
ELSE(LABELGRAPH NODES(SETQ OLDGROUP(CDAR LBLGS))
N-X))
FOR NEW LBLG2 IN LBLGS2 DO
(SETQ RESULT(CONS(CONS(UNION(CAAR LBLGS)(CAR LBLG2))
(CDR LBLG2))
RESULT))))
(RETURN RESULT))))))))))))))))))))))
COMMENT( OLD DEF OF LABELGRAPH ENDED WITH
DEFINE(((LABELGRAPH(LAMBDA(NODES GROUP NUMBER)
(COND
((NULL GROUP)(FOR NEW X IN (COMB NODES NUMBER)XLIST(CONS X NIL)))
((GREATERP(TWICE NUMBER)(SIZE NODES))
(FOR NEW X IN(LABELGRAPH NODES GROUP(DIFFERENCE(SIZE NODES)NUMBER))
XLIST (CONS (DIFF NODES (CAR X))(CDR X))))
((ZEROP NUMBER)(LIST (CONS (NULLSET) GROUP)))
(T (PROG (FC )
(COND((EQSET NODES(SETQ FC(ORBIT1 NODES GROUP)))
(RETURN(LABELCLASS NODES GROUP NUMBER))))
(SETQ NODES (DIFF NODES FC))
(RETURN (FOR NEW X :=((MAX 0(DIFFERENCE NUMBER(SIZE NODES)))
(MIN NUMBER (SIZE FC))
1)
FOR NEW LBL IN (LABELCLASS FC GROUP X)
FOR NEW LBL2 IN (LABELGRAPH NODES (CDR LBL)(DIFFERENCE NUMBER X))
XLIST (CONS(UNION (CAR LBL)(CAR LBL2))(CDR LBL2)))))))))))))))
EJECT()
COMMENT(LABELCLASS
ARGS CLASS A SET
GROUP PERMUTATION GROUP ON CLASS, SUCH THAT
ALL THE ELEMENTS OF CLASS ARE EQUIVALENT
UNDER GROUP
NUMBER NUMBER OF LABELS TO ATTACH TO CLASS
VAL A LIST OF LABELINGS, AS IN LABELGRAPH ; )
DEFINE(((LABELCLASS(LAMBDA(CLASS GROUP NUMBER)
(IF(GREATERP(TWICE NUMBER)(SIZE CLASS))
THEN
(FOR NEW X IN
(LABELCLASS CLASS GROUP (DIFFERENCE(SIZE CLASS)NUMBER))
XLIST (CONS(DIFF CLASS (CAR X))(CDR X)))
ELSEIF (ZEROP NUMBER) THEN (LIST(CONS(NULLSET)GROUP))
ELSEIF (EQUAL NUMBER 1) THEN
(LIST(CONS(SETQ CLASS(FIRST CLASS))
(REDUCEGROUP GROUP CLASS)))
ELSE (LABELGENCLASS CLASS GROUP NUMBER)))))))))))))))))))))
COMMENT(LABELGENCLASS
CALLS LABELORBITS
AND THEN REDUCES THE LIST BY
CHECKING CANONICAL
NOTE THAT AN ALTERNATIVE IS AS FOLLOWS:
(1) LABELORBITS COULD CHECK AS
IT GENERATES
(2) THE CHECKING PROCEDURE COULD
GENERATE A BADLIST, AND THE
BADLIST WOULD BE ALL THAT NEEDED
TO BE CHECKED )))))))))))))))
DEFINE(((LABELGENCLASS(LAMBDA(CLASS GROUP NUMBER)
(FOR NEW X IN (LABELORBITS(ORBITS CLASS GROUP)NUMBER)
WHEN (CANONICAL X GROUP)
XLIST (CONS X (REDUCEGROUP GROUP X))))))))))))))))))
COMMENT(LABELORBITS
ARGS ORBITS A LIST OF SETS DETERMINED FROM THE
PERMUTATION GROUP OF THE NODES TO BE LABELED:
THE I-TH SET IS THE ORBIT OF
THE I-TH NODE UNDER THOSE PERMUTATIONS
THAT LEAVE NODE 1 THROUGH NODE (I-1)
FIXED ;
NUMBER NUMBER OF LABELS TO ATTACH ;
VAL A LIST OF SUBSETS OF NODES WITH NUMBER ELEMENTS,
EACH OF WHICH SATISFY THE RELATION
IF THE I-TH NODE IS NOT IN S, THEN NO ELEMENT OF
THE I-TH ORBIT IS IN S ; )
COMMENT( TO MAKE THE LABELORBITS FUNCTION
INDEPENDENT OF WHETHER OR NOT THE LABELINGS
ARE CHECKED AS THEY ARE GENERATED, OR
IF THEY ARE ALL GENERATED AND THEN CHECKED,
LABELORBITS CALLS A FUNCTION LOADD WITH
EACH NEW LABELING; LOADD CAN THEN EITHER
ADD THAT LABELING TO A LIST, OR CHECK IT
FIRST )))))))))))))))))
SPECIAL((LORESULT))
DEFINE(((LABELORBITS(LAMBDA(ORBITS NUMBER)
(*PROG2
(SETQ LORESULT NIL)
(LO1 ORBITS NUMBER (NULLSET))
LORESULT)))))))))))
COMMENT (LO1 IS THE WORK HORSE OF LABELORBITS)
COMMENT(LO1 COULD BE MADE PARTIALLY ITERATIVE)
DEFINE(((LO1(LAMBDA(ORBITS NUMBER SET)
(IF(MINUSP NUMBER)THEN NIL
ELSEIF(ZEROP NUMBER) THEN (LOADD SET)
ELSEIF(LESSP(LENGTH ORBITS)NUMBER)THEN NIL
ELSEIF(EQUAL(LENGTH ORBITS)NUMBER)
THEN(LOADD(FOR NEW X IN ORBITS UNION FIRST SET
(FIRST X)))
ELSE
(LO1(CDR ORBITS)NUMBER SET)
(LO1(FOR NEW O IN (CDR ORBITS)
WHEN(DISJOINT(FIRST O)(CAR ORBITS))
LIST O)
(DIFFERENCE NUMBER (SIZE(CAR ORBITS)))
(UNION SET(CAR ORBITS))))))))))))))))))))
DEFINE(((LOADD(LAMBDA(NODES)(SETQ LORESULT(CONS NODES LORESULT)))))))
)))))
EJECT()
COMMENT(ORBITS
ARGS NODES A SET
GROUP PERMUTATION GROUP ON SET
VAL LIST OF ORBITS OF THE I-TH NODE UNDER
THOSE PERMUTATIONS LEAVING NODES 1 TO
I-1 FIXED )
DEFINE(((ORBITS(LAMBDA(NODES GROUP)
(COND
((EMPTY NODES)NIL)
((NULL GROUP)(LISTELT NODES))
(T(CONS
(ORBIT1 NODES GROUP)
(ORBITS (REST NODES) (REDUCEGROUP GROUP (FIRST NODES))))))))))
EJECT()
DEFINE(((CANONICAL(LAMBDA(NODES GROUP)
(FOR NEW PERM IN GROUP AND
(IF (NOT (ORDEROF PERM)) THEN
(S))PS (LARGESTELT) NODES (CAR(POWERSOF PERM)))
ELSE (FOR NEW P IN (POWERSOF PERM)
AS NEW PRED IS (S))PS&P-1S NODES P)
WHILE (NOT(EQ PRED @ EQL))
AND PRED))))))))))))))))))))))
EJECT()
COMMENT(S))PS
ARGS S A SET OF NODES
P A REPRESENTATION OF A PERMUTATION
AS THE LIST
-1 -1 -1 -1
P (X ),P (X ), P (X ) ,,, P (X )
1 2 3 N
VALUE NIL IF S IS LEXICOGRAPICALLY LESS THAN P(S)
AND T OTHERWISE
TO DETERMINE LEXICOGRAPHIC ORDER:
ORDER THE ELEMENTS OF S IN THE ORDER
X , X , X , ,,, X
1 2 3 N
ORDER THE ELEMENTS OF P(S) IN THE SAME WAY
S )) P(S) IF THE FIRST ELEMENT WHERE THEY
DIFFER, THE ELEMENT OF S IS AN EARLIER ELEMENT
THAN THE CORRESPONDING ELEMENT OF P(S)
METHOD AS I GOES FROM X1 TO XN (LARGESTELT) BY
NEXTSMALLESTELT,
-1
P (I) IN S IS THE SAME AS I IN P(S)
PROCEDE UNTIL
IT IS NO LONGER TRUE THAT
I IN S )==> I IN P(S) (I,E, P INVERSE(I) I
C
AT THAT POINT, IF I IS IN S, THEN
S>>P(S); IF I IS IN P(S) THEN
S))P(S)
)))))))))))))))))))))))))
DEFINE(((S))PS(LAMBDA(I S P)
(PROG NIL
L1 (IF (NOT (CONTAINED I S)) THEN
(IF (CONTAINED(CAR P)S) THEN (RETURN T)
ELSE (SETQ P (CDR P))
(SETQ I (NEXTSMALLESTELT I)))
ELSEIF (NOT(CONTAINED(CAR P)S)) THEN (RETURN NIL)
ELSEIF (ELTLESSP (SETQ I (NEXTSMALLESTELT I)) S)
THEN (RETURN @ EQL)
ELSE (SETQ P (CDR P)))
(GO L1)))))))))))))))
EJECT()
COMMENT(S))PS&P-1S
ARGS S A SET OF NODES
P A PERMUTATION IN THE SAME NOTATION
AS IN S))PS
VAL AS IN S))PS, THIS FUNCTION CHECKS IF
S IS LEXICOGRAPHICALLY LESS THAN P(S)
HOWEVER, AT THE SAME TIME IT CHECKS P-1(S)
METHOD AS IN S))PS, I STARTS AT THE LARGESTELT
AND GOES DOWN BY NEXTSMALLESTELT UNTIL
S AND P(S) DISAGREE
MEANWHILE, P-1(S) IS ACCUMULATED IN
R; THE COMPLIMENT OF P-1(S) IS ACCUMULATED
IN NR;
A RUNNING CHECK IS MADE ON THE FIRST
LOCATION WHERE S AND R DISAGREE
IF THAT ELEMENT IS CONTAINED IN R, THEN
IT IS KNOWN THAT P-1(S) >> S, AND IT
IS ONLY NECESSARY TO CHECK S))P(S) FROM
THEN ON;
OTHERWISE, IF XI IS THE LARGEST ELEMENT
FOR WHICH S AND R DISAGREE, AND XI IS IN
S, THEN IF ALL LARGER ELEMENTS NOT IN
S ARE IN NR, THEN WE KNOW THAT
S >> P-1(S) AND CAN RETURN )))))))))))))))))
DEFINE(((S))PS&P-1S(LAMBDA(S P)
(PROG(I R NR XI LARGERTHAN-XI&NOTIN-S)
(*SETQ R NR (NULLSET))
(SETQ LARGERTHAN-XI&NOTIN-S
(ALLLARGERELTS (SETQ XI (FIRST S))))
(SETQ I (LARGESTELT))
LOOP(IF (CONTAINED I S) THEN
(IF (CONTAINED (CAR P) S) THEN
(COMMENT S AND P(S) AGREE SO FAR; CHECK P-1(S)
I IS IN S, SO WE ADD (CAR P) TO R)
(SETQ R (UNION (CAR P) S))
(IF(CONTAINED(SETQ XI(FIRST(DISJOINTDIFF S R)))R)
THEN (COMMENT THE LARGEST ELEMENT WHERE S AND R
DISAGREE IS IN R; THUS P-1(S) IS BIGGER
THAN S, AND WE NEED ONLY TO CHECK P(S))
(RETURN(S))PS I S P))
ELSEIF(AND
(CONTAINED(SETQ LARGERTHAN-XI&NOTIN-S
(DIFF(ALLLARGERELTS XI)S))
NR)
(CONTAINED XI NR))
THEN (RETURN NIL)
ELSE NIL)
ELSE (COMMENT I IN S, NOT IN P(S) MEANS S BIGGER)
(RETURN NIL))
ELSEIF (CONTAINED(CAR P)S) THEN
(COMMENT I NOT IN S, BUT IN P(S) MEANS
S IS SMALLER THAN P(S); WE NEED TO CHECK
P-1(S) ONLY FROM NOW ON)
(GO INVERSE-ONLY)
ELSE (COMMENT I NOT IN S OR IN P(S);
SINCE I IS NOT IN S, WE ADD P-1(S) TO
NR AND CHECK NR)
(IF(AND(CONTAINED XI(SETQ NR(UNION(CAR P)NR)))
(CONTAINED LARGERTHAN-XI&NOTIN-S
NR))
THEN (RETURN NIL)
ELSE NIL)
)
(COMMENT GO TO NEXT ELEMENTS)
(IF(OR(ELTLESSP(SETQ I(NEXTSMALLESTELT I))S)
(NULL(SETQ P(CDR P))))
THEN (RETURN(QUOTE EQL)))
(GO LOOP)
INVERSE-ONLY
(COMMENT S))P(S); CHECK IF S))P-1(S))
(COMMENT AT THIS POINT, I IS NOT IN S,
I IS IN P(S); WE NEED TO ADD P-1(I) TO NR)
(SETQ NR (UNION I NR))
LOOP2
(COMMENT R HAS NOT CHANGED FROM LAST TIME;
THUS XI HAS NOT CHANGED EITHER)
(IF (AND(CONTAINED XI NR)
(CONTAINED LARGERTHAN-XI&NOTIN-S
NR))
THEN (RETURN NIL))
(IF(NULL(SETQ P(CDR P))) THEN (RETURN @ EQL))
(SETQ I (NEXTSMALLESTELT I))
(IF(CONTAINED I S) THEN
(SETQ R (UNION I R))
(IF(CONTAINED(SETQ XI(FIRST(DISJOINTDIFF S R)))R)
THEN (RETURN T)
ELSE NIL)
(SETQ LARGERTHAN-XI&NOTIN-S
(DIFF(ALLLARGERELTS XI)S))
)
(GO LOOP2))))))))))))))))))))))))))))))
EJECT()
COMMENT(POLYA
ARGS NODES A SET TO BE LABELED
GROUP A GROUP OF PERMUTATIONS
ON NODES
SUBLIST A COLLECTION OF "LABELS"
TO BE ASSIGNED TO NODES
IN COMPOSITION LIST FORM
VAL THE NUMBER OF WAYS THE LABELS IN SUBLIST
CAN BE ASSIGNED TO NODES WITHOUT DUPICATION
UNDER THE PERMUTATIONS OF GROUP
THIS FUNCTION EVALUATES G, POLYA'S FUNCTION FOR THE
NUMBER OF DOUBLE COSETS OF TWO GROUPS UNDER S(N) ;
METHOD
(COMMENT RESET SUBLIST TO AN ORDERED LIST OF THE
NUMBER OF DIFFERENT SUBSTITUANTS; MUST FILL
IN IF THE NUMBER OF SUBSTITUANTS IS LESS THAN
THE NUMBER OF NODES TO LABEL)
(COMMENT RESET GROUP TO A COMPOSITION LIST
OF CYCLE INDICES; TH IDENTITY NEEDS TO BE
FILLED IN; THE FUNCTION PERMCYCLEINDEX1
GIVEN A PERMUTATION RETURNS A LIST OF THE
SIZES OF THE CYCLES OF THE PERM, BUT CYCLES
OF SIZE ONE ARE NOT INCLUDED; NOTE ALSO
THAT EACH PERMUTATION IN THE ORIGINAL GROUP
STANDS FOR 2 *(LENGTH (ORDEROF PERM)) PERMUTATIONS
UNLESS ORDEROF IS NIL, IN WHICH CASE IT
STANDS FOR ONLY ONE PERMUTATION)
(COMMENT NOW TO COMPUTE THE COEFICIENT OF
N1 N2 NK
X1 X2 ,,, XK
IN THE POLYNOMIAL
!C! !C! !C!
SUM PRODUCT(X1 + X2 ,,, + XK )
P IN C CYCLE
GROUP OF P
SUBLIST IS (N1 N2 ,,, NK) AND
NEWGROUP IS THE POLYNOMIAL
WITH REDUNDANCIES IN THE SUM AND PRODUCT
ELIMINATED BY USING COMPOSITION LISTS
)
)
GSET(INPUTMODE FUNCTION)
DEFINE(((POLYA(LAMBDA(NODES GROUP SUBLIST)
(PROG(D C NEWGROUP)
(SETQ SUBLIST (LFROMCL SUBLIST (SIZE NODES)))
(SETQ NEWGROUP (CYCLEINDEX GROUP NODES))
(SETQ C (FOR NEW PERM IN NEWGROUP PLUS (CDR PERM)))
L1(IF(NULL(CDR SUBLIST))
THEN (RETURN(QUOTIENT(FOR NEW X IN NEWGROUP PLUS (CDR X))C)))
(SETQ GROUP NEWGROUP) (SETQ NEWGROUP NIL)
(FOR NEW X IN GROUP
FOR NEW S IN (SUBSETS (CAR X)(CAR SUBLIST))
AS NEW CYCLEFT IS (DIFFCL (CAR X) (CAR S))
AS NEW FACTOR IS (TIMES (CDR X)(CDR S))
DO (SETQ NEWGROUP
(INSERTCL
FACTOR
CYCLEFT
NEWGROUP
(FUNCTION(LAMBDA(X Y)(NOT(GEQ X Y)))))))
(SETQ SUBLIST (CDR SUBLIST))
(GO L1))))))))))))))
DEFINE(((LFROMCL(LAMBDA(CL N)
(PROG2
(SETQ CL (SORT (MAPCAR CL @ CDR) @ LESSP))
(IF(NOT(ZEROP(SETQ N (DIFFERENCE N (*LUS CL)))))
THEN (INSERT N CL @ LESSP)
ELSE CL)))))))))))))))))))
DEFINE(((CYCLEINDEX(LAMBDA(GROUP NODES)
(PROG(INDEX)
(FOR NEW PERM IN GROUP
AS NEW DUPLICITY IS
(IF(OR(NOT(ORDEROF PERM))(EQ INPUTMODE @ FUNCTION))
THEN 1
ELSE (TWICE(LENGTH(ORDEROF PERM))))
DO
(SETQ INDEX
(INSERTCL DUPLICITY
(PCYCLEINDEX (CYCLESOF PERM)NODES)
INDEX
(FUNCTION(LAMBDA(X Y)(NOT(GEQ X Y)))))))
(RETURN(CONS (CONS(LIST(CONS 1(SIZE NODES)))1)
INDEX))))))))))))))))))))))
DEFINE(((PCYCLEINDEX(LAMBDA(CYCLES NODES)
(PROG(INDEX)
(FOR NEW CYCLE IN CYCLES
AS NEW CYCLESIZE IS (SIZE(INTERSECT(SETOF CYCLE)NODES))
DO (SETQ INDEX (INSERTCL 1 CYCLESIZE INDEX @ LESSP)))
(RETURN(IF(NOT(ZEROP(SETQ CYCLES
(DIFFERENCE (SIZE NODES)
(FOR NEW X IN INDEX PLUS
(TIMES(CAR X)(CDR X)))))))
THEN (CONS(CONS 1 CYCLES)INDEX)
ELSE INDEX)))))))))))))))))))))))))))))))))))
EJECT()
COMMENT(SUBSETS
ARGS C A LIST OF THE FORM
((L1 . M1)(L2 . M2) -- (LQ . MQ))
THE L'S AND M'S ARE NUMBERS-- THIS REPRESENTS
A COLLECTION OF NUMBERS ;THE NUMBERS ARE THE
L'S AND THE M'S ARE HOW MANY OF EACH OCCUR;
N A NUMBER
VALUE A LIST OF DOTTED PAIRS ;THE CAR OF EACH
IS A SUBCOLLECTION OF C SUCH THAT THE ELEMENTS OF
THAT SUBCOLLECTION ADD UP TO N ;THE CDR IS THE
NUMBER OF WAYS THAT SUBCOLLECTION CAN BE FORMED
FROM THE L'S IF THE L'S WERE ALL DIFFERENT
E,G, SUBSETS(((5 . 1)(4 . 2)(1 . 1)) 5)
YIELDS (((5 . 1)) . 1)
(((4 . 1)(1 . 1)) . 2)
SINCE 5 CAN BE OBTAINED BY TAKING ONE 5 IN
ONE WAY ;OR BY TAKING A FOUR AND A ONE IN TWO
DIFFERENT WAYS;
)
DEFINE(((SUBSETS(LAMBDA(C N)
(COND
((ZEROP N)@((NIL . 1)))
((FOR C ON C AND (GREATERP (CAAR C) N)) NIL)
(COMMENT GET RID OF NUMBERS AT HEAD THAT ARE TOO BIG)
(COMMENT RETURN NIL WHEN THEY ALL ARE TO BIG)
(T (FOR NEW I :=(1 (CDAR C)) AS NEW II :=((CAAR C) N (CAAR C))
(COMMENT THE FIRST ELEMENT OF THE NEW SUBSET
IS THE FIRST OF THE OLD ;TRY UP TO HOW MANY
ON THE OLD ;I IS THE NUMBER OF TIMES IT
OCCURS AND II IS THE AMOUNT TAKEN ;IT IS
UPPER-BOUNDED BY N)
AS NEW X IS (SUBSETS (CDR C) (DIFFERENCE N II))
(COMMENT TRY EVERY SUBSET OF THE REST ADDING UP TO N-II)
WHEN X AS NEW FACTOR IS (TAKEN (CDAR C) I)
(COMMENT X MUST NOT BE NIL ;THE FACTOR IS THE NUMBER
OF WAYS OF TAKING I ELEMENTS OUT OF THE (CDAR C) ELEMENT
AVAILABLE)
FOR X ON X
XLIST FIRST (SUBSETS (CDR C) N)
(COMMENT THE FIRST OF THE LIST IS ALL SUBSETS WITHOUT
USING THE FIRST OF C)
(CONS (CONS(CONS(CAAR C)I)(CAAR X)) (TIMES FACTOR(CDAR X)))))))
)))))))))))))
COMMENT(DIFFCL
ARGS L1, L2 TWO COMPOSITION LISTS
VAL THE DIFFERENCE (L1 - L2) )
DEFINE(((DIFFCL(LAMBDA(L1 L2)
(FOR NEW X IN L1
AS NEW N IS (DIFFERENCE(CDR X)(ASSOC(CAR X)L2 0))
WHEN (GREATERP N 0)
LIST (CONS(CAR X) N))))))))))))))))))
COMMENT(INSERTCL
ARGS NUMBER THE NUMBER OF THIS TYPE OF ELEMENT TO INSERT
ELEMENT THE ELEMENT TO INSERT
OLDCL THE COMPOSITION LIST THAT NUMBER ELEMENTS
ARE TO BE INSERTED INTO
ORDERF A COMPARISON FUNCTION WHICH RETURNS
NIL IF THE TWO ARGUMENTS ARE EQUAL
OR IF THE FIRST SHOULD COME AFTER
THE SECOND IN THE COMPOSITION LIST
VAL OLDCL, WITH NUMBER ELEMENTS ADDED
OLDCL IS ASSUMED TO BE PREVIOUSLY SORTED BY ORDERF )
DEFINE(((INSERTCL(LAMBDA(NUMBER ELEMENT OLDCL ORDERF)
(IF (OR(NULL OLDCL)(ORDERF ELEMENT (CAAR OLDCL)))
THEN (CONS(CONS ELEMENT NUMBER)OLDCL)
ELSEIF (NOT(ORDERF (CAAR OLDCL) ELEMENT))
THEN (RPLACD (CAR OLDCL) (PLUS (CDAR OLDCL) NUMBER))
OLDCL
ELSE
(FOR NEW CL ON OLDCL DO
(IF (OR (NULL(CDR CL)) (ORDERF ELEMENT (CAADR CL)))
THEN (RETURN (RPLACD CL (CONS(CONS ELEMENT NUMBER)(CDR CL))))
ELSEIF (NOT (ORDERF (CAADR CL) ELEMENT))
THEN (RETURN (RPLACD (CADR CL) (PLUS (CDADR CL) NUMBER)))))
OLDCL))))))))))))))
EJECT()
COMMENT(CHECK IS A FUNCTION WHICH TAKES TWO
ARGUMENTS, A FUNCTION NAME, AND A LAMBDA EXPRESSION ;
THE LAMBDA VARIABLES SHOULD MATCH IN NUMBER AND
TYPE THE LAMBDA ARGUMENTS OF THE FUNCTION NAMED ;
THE EXPRESSION PART OF THE LAMBDA EXPRESSION SHOULD
EVALUATE THE THE EXPECTED LENGTH OF THE RESULT OF
THE FUNCTION NAMED ;
CHECK REDEFINES THE FUNCTION TO CHECK ITS RESULTS
AGAINST THE GIVEN LAMBDA EXPRESSION AND TO PRINT
A MESSAGE IF THE LENGTH OF THE VALUE OF THE FUNCTION
DOES NOT MATCH THE VALUE OF THE EXPRESSION ;
CHECK CAN BE USED WITH POLYA TO CHECK MOST OF
THE FUNCTIONS IN THE DOUBLE COSET GENERATOR
)
DEFINE(((CHECK(LAMBDA(FN LEXP)
(PROG(NF)
(SETQ NF(COMPRESS(LIST FN @ *CHK)))
(COND((GET FN @ SUBR)
(PROG2(PUTPROP NF(GET FN @ SUBR)@ SUBR)(REMPROP FN @ SUBR)))
((GET FN @ EXPR)(PUTPROP NF(GET FN @ EXPR)@ EXPR))
(T (RETURN @(? FN NOT EXPR OR SUBR))))
(DEFINE @((? FN (LAMBDA ?(CADR LEXP)
(PROG(CNT RES)
(SETQ RES ?(CONS NF (CADR LEXP)))
(SETQ CNT ?(CADDR LEXP))
(COND((EQUAL(LENGTH RES)CNT)(RETURN RES)))
(PRINT(QUOTE (ERROR IN:)))
(PRIN1 (QUOTE ? FN))
(PRINT ?(CONS @ LIST (CADR LEXP)))
(PRIN1 (QUOTE "PREDICTED NUMBER="))
(PRINT CNT)
(PRIN1 (QUOTE "ACTUAL NUMBER="))
(PRINT (LENGTH RES))
(PRIN1 (QUOTE "VALUE IS="))
(PRINT RES)
(EXITERR T)
(ERROR (QUOTE ? FN))))))))))))))))))))))))
COMMENT((PERMUTATION FUNCTIONS))
FIXDEFINE((COMPILE))
DEFINE(((MAPPINGS(LAMBDA(A A2 B)
(COND((NULL A)(LIST B))
((NULL B)NIL)
((NOT(MEMBER(CAR B)A))(MAPCONS(CAR B)(MAPPINGS A A2 (CDR B))))
(T(IMAGES A2 NIL A B))))))))))
DEFINE(((IMAGES(LAMBDA(A2A A2B A B)
(COND((NULL A2A) NIL)
(T(APPEND
(MAPCONS(CAR A2A)(MAPPINGS(CDR A)(APPEND(CDR A2A)A2B)(CDR B)))
(IMAGES(CDR A2A)(CONS(CAR A2A)A2B)A B)))))))))))))))))
DEFINE(((MAPCONS(LAMBDA(X L)(MAPCAR L(FUNCTION(LAMBDA(Y)(CONS X Y)))))))
))))))))))
DEFINE(((D1(LAMBDA(I N Y A)
(COND((GREATERP I N) NIL)
((NULL Y) (CONS I (D1 (ADD1 I) N A A)))
((NOT(EQUAL I (CAR Y)))(D1 I N (CDR Y) A))
((CDR Y) (CONS (CADR Y) (D1 (ADD1 I) N A A)))
(T (CONS (CAR A) (D1 (ADD1 I) N A A)))))))))))))))
DEFINE(((D2(LAMBDA(A N)(D1 1 N A A)))))))
DEFINE(((XTIMES1(LAMBDA(X I P)
(COND((EQUAL X I)(CAR P))
(T(XTIMES1 X (ADD1 I) (CDR P)))))))))
DEFINE(((XTIMES(LAMBDA(X P)(XTIMES1 X 1 P)))))))
DEFINE(((PTIMES(LAMBDA(P1 P2)
(MAPCAR P1(FUNCTION(LAMBDA(Z)(XTIMES Z P2))))))))))
DEFINE(((CYCLICGENBY(LAMBDA(P)
(CYC1 P (PTIMES P P)))))))))
DEFINE(((CYC1(LAMBDA(P1 P2)
(COND((EQUAL P1 P2)(LIST P1))
(T(CONS P2 (CYC1 P1 (PTIMES P1 P2)))))))))))))))
DEFINE(((DIRECTPRODUCT(LAMBDA(G1 G2)
(COND((NULL G1) NIL)
(T(DP1 (CAR G1) G2 (DIRECTPRODUCT (CDR G1) G2))))))))))
DEFINE(((DP1(LAMBDA(P G PRD)
(COND((NULL G) PRD)
(T(DP2 (PTIMES P (CAR G)) P G PRD))))))))
DEFINE(((DP2(LAMBDA(PCG P G PRD)
(COND((MEMBER PCG PRD)(DP1 P (CDR G) PRD))
(T(DP1 P (CDR G) (CONS PCG PRD)))))))))))))
DEFINE(((IDENTITY(LAMBDA(N)
(ID1 1 N)))))))))))
DEFINE(((ID1(LAMBDA(I N)
(COND((GREATERP I N)NIL)
(T(CONS I(ID1(ADD1 I)N)))))))))))))))
DEFINE(((SN(LAMBDA(A N)(MAPPINGS A A (IDENTITY N))))))))
DEFINE(((R1(LAMBDA(A B N)
(COND((GREATERP(LENGTH A)(ADD1(LENGTH B)))
(R1(CDR A)(CONS(CAR A)B) N))
((NULL B)(IDENTITY N))
(T(PTIMES(CADR(SN(LIST(MIN(CAR A)(CAR B))(MAX(CAR A)(CAR B)))N))
(R1(CDR A)(CDR B)N)))))))))))
DEFINE(((REFLECTION(LAMBDA(A N)(R1 A NIL N)))))))
DEFINE(((DIHEDRAL(LAMBDA(A N)
(DIRECTPRODUCT(LIST(REFLECTION A N)(IDENTITY N))
(CYCLICGENBY (D2 A N)))))))))))))
DEFINE(((PRISM(LAMBDA(A B N)
(DIRECTPRODUCT(LIST(R1 A B N)(IDENTITY N))
(PR1(DIHEDRAL A N)(R1 A B N)))))))))
DEFINE(((PR1(LAMBDA(N P)
(MAPCAR N(FUNCTION(LAMBDA(X)(PTIMES X (PTIMES P (PTIMES X P))))))))))
DEFINE(((GROUPGENBY(LAMBDA(G)
(GG1 G G G)
))))))
DEFINE(((GG1(LAMBDA(G1 G2 G)
(COND((NULL G1)G)
((NULL G2)(GG1(CDR G1)(CDR G1)G))
(T(GG2(PTIMES(CAR G1)(CAR G2))G1 G2 G)))))))
DEFINE(((GG2(LAMBDA(G1*2 G1 G2 G)
(COND((MEMBER G1*2 G)(GG1 G1 (CDR G2) G))
(T(PROG2(RPLACD G2(CONS G1*2 (CDR G2)))
(GG1 G1 (CDR G2) G)))))))))))
OPEN(CYCORE5 SYSFILE OUTPUT)CHKPOINT(CYCORE5)CLOSE(CYCORE5)
EJECT()
COMMENT( METHODS OF INCREASING EFFICIENCY OF THIS PROGRAM
(1) ALLOW THE POSSIBILITY OF A GROUP BEING REPRESENTED AS
A DIRECT PRODUCT OF GROUPS, OR OF A GROUP BEING REPRESENTED
BY ITS GENERATORS -- THIS PERHAPS WILL SIMPLIFY REDUCEGROUP
ORBITS, ETC
(2) COMB SHOULD NOT RETURN ALL COMBINATIONS, BUT A SPECIAL FORM ;
ALL OTHER FUNCTIONS SHOULD BE ABLE TO HANDLE THIS FORM
OF A LABELING
(3) IT MAY BE POSSIBLE TO INCORPERATE THE CANONICAL TEST INTO
THE LABELORBITS PROCEDURE -- THIS WOULD BE A LARGE SAVINGS
(4) IF NOT, IT MAY BE POSSIBLE TO DETECT IN ADVANCE WHICH PERMS
MIGHT POSSIBLY TAKE X INTO A SMALLER X
(6) ANOTHER REPRESENTATION FOR PERMUTATIONS, MORE SUITED TO
THE MPERM ROUTINE, CAN BE ADDED & CARRIED ALONG BY ADDING
ANOTHER ATTRIBUTE TO PERMUTATIONS
(7) IN ALMOST ALL CASES, IT IS EASY TO COMPUTE P**1 X WHEN
COMPUTING P X ;THIS WOULD REDUCE CANONICAL GREATLY
(8) CARRY ALONG WITH EACH PERMUTATION P** SUCH THAT N IS RELATIVELY
PRIME TO ALL OF THE CYCLE LENGTHS OF P -- THUS INSTEAD OF
APPLYING P TO X A COMPUTED NUMBER OF TIMES, ONE APPIES THESE
TO X ONCE EACH -- COMPUTATION CAN BE SAVED THIS WAY
(9) IF THE COMBONITORIC TAKEN RELATIVELY PRIME, ETC ARE TAKING
TOO MUCH TIME, PUT PART OF THE VALUES IN TABLES
THINGS TO DO TO MAKE IT A NICER PROGRAM
(1) INPUT ONLY THE GENERATORS OF THE GROUP RATHER THAN THE WHOLE GROUP
(2) FIX UP OUTPUT
)))))))))))))))))))))))))))
COMMENT(